home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE23 / PASTOWEB / Convert.pas next >
Encoding:
Pascal/Delphi Source File  |  1997-05-20  |  15.1 KB  |  548 lines
  1. unit Convert;
  2.  
  3. interface
  4.  
  5. uses
  6.   Classes, NewParse;
  7.  
  8. type
  9.   KeywordType = (ktPascal, ktDfm);
  10.  
  11.   TCodeParser = class (TNewParser)
  12.   public
  13.     constructor Create (SSource, SDest: TStream);
  14.     procedure SetKeywordType (Kt: KeywordType);
  15.     // conversion
  16.     procedure Convert;
  17.   protected
  18.     // virtual methods (mostly virtual abstract)
  19.     procedure BeforeString; virtual; abstract;
  20.     procedure AfterString; virtual; abstract;
  21.     procedure BeforeKeyword; virtual; abstract;
  22.     procedure AfterKeyword; virtual; abstract;
  23.     procedure BeforeComment; virtual; abstract;
  24.     procedure AfterComment; virtual; abstract;
  25.     procedure InitFile; virtual; abstract;
  26.     procedure EndFile; virtual; abstract;
  27.     function CheckSpecialToken (Ch1: char): string; virtual;
  28.     function MakeStringLegal (S: String): string; virtual;
  29.     function MakeCommentLegal (S: String): string; virtual;
  30.   protected
  31.     Source, Dest: TStream;
  32.     OutStr: string;
  33.     FKeywords: TStrings;
  34.     Line, Pos: Integer;
  35.   end;
  36.  
  37.   THtmlParser = class (TCodeParser)
  38.   public
  39.     FileName: string;
  40.     Copyright: string;
  41.     Alone: Boolean;
  42.     procedure AddFileHeader (FileName: string);
  43.     class function HtmlHead (Filename: string): string;
  44.     class function HtmlTail (Copyright: string): string;
  45.   protected
  46.     // virtual methods
  47.     procedure BeforeString; override;
  48.     procedure AfterString; override;
  49.     procedure BeforeKeyword; override;
  50.     procedure AfterKeyword; override;
  51.     procedure BeforeComment; override;
  52.     procedure AfterComment; override;
  53.     procedure InitFile; override;
  54.     procedure EndFile; override;
  55.     function CheckSpecialToken (Ch1: char): string; override;
  56.   end;
  57.  
  58. // functions to be used by a Wizard
  59. function OpenProjectToHTML (Filename, Copyright: string): string;
  60. function CurrProjectToHTML (Copyright: string): string;
  61.  
  62. implementation
  63.  
  64. uses
  65.   ExptIntf, SysUtils, ToolIntf;
  66.  
  67. var
  68.   PascalKeywords: TStrings;
  69.   DfmKeywords: TStrings;
  70.  
  71. const
  72.   Quote = '''';
  73.  
  74. //////////// class TCodeParser ////////////
  75.  
  76. constructor TCodeParser.Create (SSource, SDest: TStream);
  77. begin
  78.   inherited Create (SSource);
  79.   Source := SSource;
  80.   Dest := SDest;
  81.   SetLength (OutStr, 10000);
  82.   OutStr := '';
  83.   FKeywords := PascalKeywords;
  84. end;
  85.  
  86. procedure TCodeParser.SetKeywordType (Kt: KeywordType);
  87. begin
  88.   case Kt of
  89.     ktPascal: FKeywords := PascalKeywords;
  90.     ktDfm: FKeywords := DfmKeywords;
  91.   else
  92.     raise Exception.Create ('Undefined keywords type');
  93.   end;
  94. end;
  95.  
  96. procedure TCodeParser.Convert;
  97. begin
  98.   InitFile; // virtual
  99.   Line := 1;
  100.   Pos := 0;
  101.   // parse the entire source file
  102.   while Token <> toEOF do
  103.   begin
  104.     // if the source code line has changed,
  105.     // add the proper newline character
  106.     while SourceLine > Line do
  107.     begin
  108.       AppendStr (OutStr, #13#10);
  109.       Inc (Line);
  110.       Pos := Pos + 2; // 2 characters, cr+lf
  111.     end;
  112.     // add proper white spaces (formatting)
  113.     while SourcePos > Pos do
  114.     begin
  115.       AppendStr (OutStr, ' ');
  116.       Inc (Pos);
  117.     end;
  118.     // check the token
  119.     case Token of
  120.       toSymbol:
  121.       begin
  122.         // if the token is not a keyword
  123.         if FKeywords.IndexOf (TokenString) < 0 then
  124.           // add the plain token
  125.           AppendStr (OutStr, TokenString)
  126.         else
  127.         begin
  128.           BeforeKeyword; // virtual
  129.           AppendStr (OutStr, TokenString);
  130.           AfterKeyword; // virtual
  131.         end;
  132.       end;
  133.       toString:
  134.       begin
  135.         BeforeString; // virtual
  136.         if (Length (TokenString) = 1) and
  137.           (Ord (TokenString [1]) < 32) then
  138.           begin
  139.             AppendStr (OutStr, '#' +
  140.               IntToStr (Ord (TokenString [1])));
  141.             if Ord (TokenString [1]) < 10 then
  142.               Pos := Pos + 1
  143.             else
  144.               Pos := Pos + 2;
  145.           end
  146.         else
  147.         begin
  148.           AppendStr (OutStr, MakeStringLegal (TokenString));
  149.           Pos := Pos + 2; // 2 x hypen
  150.         end;
  151.         AfterString; // virtual
  152.       end;
  153.       toInteger:
  154.         AppendStr (OutStr, TokenString);
  155.       toFloat:
  156.         AppendStr (OutStr, TokenString);
  157.       toComment:
  158.       begin
  159.         BeforeComment; // virtual
  160.         AppendStr (OutStr, MakeCommentLegal (TokenString));
  161.         AfterComment; // virtual
  162.       end;
  163.       else
  164.         // any other token
  165.         AppendStr (OutStr, CheckSpecialToken (Token));
  166.     end; // case Token of
  167.     // increase the current position
  168.     Pos := Pos + Length (TokenString);
  169.     // move to the next token
  170.     NextToken;
  171.   end; // while Token <> toEOF do
  172.   // add final code
  173.   EndFile; // virtual
  174.   // add the string to the stream
  175.   Dest.WriteBuffer (Pointer(OutStr)^, Length (OutStr));
  176. end;
  177.  
  178. function TCodeParser.CheckSpecialToken (Ch1: char): string;
  179. begin
  180.   Result := Ch1; // do nothing
  181. end;
  182.  
  183. function TCodeParser.MakeStringLegal (S: String): string;
  184. var
  185.   I: Integer;
  186. begin
  187.   if Length (S) < 1 then
  188.   begin
  189.     Result := Quote + Quote;
  190.     Exit;
  191.   end;
  192.  
  193.   // if the first character is not special,
  194.   // add the open quote
  195.   if S[1] > #31 then
  196.     Result := Quote
  197.   else
  198.     Result := '';
  199.  
  200.   // for each character of the string
  201.   for I := 1 to Length (S) do
  202.     case S [I] of
  203.  
  204.       // quotes must be doubled
  205.       Quote: begin
  206.         AppendStr (Result, Quote + Quote);
  207.         Pos := Pos + 1;
  208.       end;
  209.  
  210.       // special characters (characters below the value 32)
  211.       #0..#31: begin
  212.         Pos := Pos + Length (IntToStr (Ord (S[I])));
  213.         // if preceeding characters are plain ones,
  214.         // close the string
  215.         if (I > 1) and (S[I-1] > #31) then
  216.           AppendStr (Result, Quote);
  217.         // add the special character
  218.         AppendStr (Result, '#' + IntToStr (Ord (S[I])));
  219.         // if the following characters are plain ones,
  220.         // open the string
  221.         if (I < Length (S) - 1) and (S[I+1] > #31) then
  222.           AppendStr (Result, Quote);
  223.       end;
  224.     else
  225.       AppendStr (Result, CheckSpecialToken(S[I]));
  226.   end;
  227.  
  228.   // if the last character was not special,
  229.   // add closing quote
  230.   if (S[Length (S)] > #31) then
  231.     AppendStr (Result, Quote);
  232. end;
  233.  
  234. function TCodeParser.MakeCommentLegal (S: String): string;
  235. var
  236.   I: Integer;
  237. begin
  238.   Result := '';
  239.   // for each character of the string
  240.   for I := 1 to Length (S) do
  241.     AppendStr (Result, CheckSpecialToken(S[I]));
  242. end;
  243.  
  244. //////////// class THtmlParser ////////////
  245.  
  246. procedure THtmlParser.InitFile;
  247. begin
  248.   if Alone then
  249.     AppendStr (OutStr, HtmlHead (Filename));
  250.   AddFileHeader (Filename);
  251.   AppendStr (OutStr, '<PRE>'#13#10);
  252. end;
  253.  
  254. procedure THtmlParser.EndFile;
  255. begin
  256.   AppendStr (OutStr, '</PRE>');
  257.   if Alone then
  258.     AppendStr (OutStr, HtmlTail (Copyright))
  259.   else
  260.     AppendStr (OutStr, #13#10'<HR>'#13#10#13#10); // separator
  261. end;
  262.  
  263. procedure THtmlParser.BeforeComment;
  264. begin
  265.   AppendStr (OutStr, '<FONT COLOR="#000080"><I>');
  266. end;
  267.  
  268. procedure THtmlParser.AfterComment;
  269. begin
  270.   AppendStr (OutStr, '</I></FONT>');
  271. end;
  272.  
  273. procedure THtmlParser.BeforeKeyword;
  274. begin
  275.   AppendStr (OutStr, '<B>');
  276. end;
  277.  
  278. procedure THtmlParser.AfterKeyword;
  279. begin
  280.   AppendStr (OutStr, '</B>');
  281. end;
  282.  
  283. procedure THtmlParser.BeforeString;
  284. begin
  285.   // no special style...
  286. end;
  287.  
  288. procedure THtmlParser.AfterString;
  289. begin
  290.   // no special style...
  291. end;
  292.  
  293. function THtmlParser.CheckSpecialToken (Ch1: char): string;
  294. begin
  295.   case Ch1 of
  296.     '<': Result := '<';
  297.     '>': Result := '>';
  298.     '&': Result := '&';
  299.     '"': Result := '"';
  300.   else
  301.     Result := Ch1;
  302.   end;
  303. end;
  304.  
  305. procedure THtmlParser.AddFileHeader (FileName: string);
  306. var
  307.   FName: string;
  308. begin
  309.   FName := Uppercase (ExtractFilename (FileName));
  310.   AppendStr (OutStr, Format (
  311.     '<A NAME=%s><H3>%s</H3></A>' + #13#10 + #13#10,
  312.     [FName, FName]));
  313. end;
  314.  
  315. class function THtmlParser.HtmlHead (Filename: string): string;
  316. begin
  317.   Result := '<HTML><HEAD>' + #13#10 +
  318.     '<TITLE>File: ' +  ExtractFileName(Filename) + '</TITLE>' + #13#10 +
  319.     '<META NAME="GENERATOR" CONTENT="PasToWeb[Marco Cant∙]">'#13#10 +
  320.     '</HEAD>'#13#10 +
  321.     '<BODY BGCOLOR="#FFFFFF">'#13#10;
  322. end;
  323.  
  324. class function THtmlParser.HtmlTail (Copyright: string): string;
  325. begin
  326.   Result := '<HR><CENTER<I>Generated by PasToWeb,' +
  327.     ' a tool by Marco Cantù.<P>' + #13#10 +
  328.     Copyright + '</CENTER></I>'#13#10 + '</BODY> </HTML>';
  329. end;
  330.  
  331. // code for the wizard...
  332.  
  333. function OpenProjectToHTML (Filename, Copyright: string): string;
  334. begin
  335.   // open the project and get the lists...
  336.   ToolServices.OpenProject (FileName);
  337.   Result := CurrProjectToHTML (Copyright);
  338. end;
  339.  
  340. function CurrProjectToHTML (Copyright: string): string;
  341. var
  342.   Dest, Source, BinSource: TStream;
  343.   HTML, FileName, Ext, FName: string;
  344.   I: Integer;
  345.   Parser: THtmlParser;
  346. begin
  347.   // initialize
  348.   FileName := ToolServices.GetProjectName;
  349.   Result := ChangeFileExt (FileName, '_dpr') + '.htm';
  350.   Dest := TFileStream.Create (Result,
  351.     fmCreate or fmOpenWrite);
  352.   try
  353.     // add head
  354.     HTML := '<HTML><HEAD>' + #13#10 +
  355.       '<TITLE>Project: ' +  ExtractFileName (Filename) +
  356.         '</TITLE>' + #13#10 +
  357.       '<META NAME="GENERATOR" CONTENT="PasToHTML[Marco Cant∙]">' + #13#10 +
  358.       '</HEAD>'#13#10 +
  359.       '<BODY BGCOLOR="#FFFFFF">'#13#10 +
  360.       '<H1><CENTER>Project: ' + FileName +
  361.       '</CENTER></H1><BR><BR><HR>'#13#10;
  362.     AppendStr (HTML, '<UL>'#13#10);
  363.     // units list
  364.     for I := 0 to ToolServices.GetUnitCount - 1 do
  365.     begin
  366.       Ext := Uppercase (ExtractFileExt(
  367.         ToolServices.GetUnitName(I)));
  368.       FName := Uppercase (ExtractFilename (
  369.         ToolServices.GetUnitName(I)));
  370.       if (Ext <> '.RES') and (Ext <> '.DOF') then
  371.         AppendStr (HTML, '<LI> <A HREF=#' + FName + '> ' +
  372.           FName + '</A>'#13#10);
  373.     end;
  374.     // forms list
  375.     for I := 0 to ToolServices.GetFormCount - 1 do
  376.     begin
  377.       FName := Uppercase (ExtractFilename (
  378.         ToolServices.GetFormName(I)));
  379.       AppendStr (HTML, '<LI> <A HREF=#' + FName + '> ' +
  380.         FName + '</A>'#13#10);
  381.     end;
  382.     AppendStr (HTML, '</UL>'#13#10);
  383.     AppendStr (HTML, '<HR>'#13#10);
  384.     // add the HTML string to the output buffer
  385.     Dest.WriteBuffer (Pointer(HTML)^, Length (HTML));
  386.  
  387.     // generate the HTML code for the units
  388.     for I := 0 to ToolServices.GetUnitCount - 1 do
  389.     begin
  390.       Ext := Uppercase (ExtractFileExt(
  391.         ToolServices.GetUnitName(I)));
  392.       if (Ext <> '.RES') and (Ext <> '.DOF') then
  393.       begin
  394.         Source := TFileStream.Create (
  395.           ToolServices.GetUnitName(I), fmOpenRead);
  396.         Parser := THtmlParser.Create (Source, Dest);
  397.         try
  398.           Parser.Alone := False;
  399.           Parser.Filename := ToolServices.GetUnitName(I);
  400.           Parser.Convert;
  401.         finally
  402.           Parser.Free;
  403.           Source.Free;
  404.         end;
  405.       end; // if
  406.     end; // for
  407.  
  408.     // generate the HTML code for forms
  409.     for I := 0 to ToolServices.GetFormCount - 1 do
  410.     begin
  411.       // convert the DFM file to text
  412.       BinSource := TFileStream.Create (
  413.         ToolServices.GetFormName(I), fmOpenRead);
  414.       Source := TMemoryStream.Create;
  415.       ObjectResourceToText (BinSource, Source);
  416.       Source.Position := 0;
  417.       Parser := THtmlParser.Create (Source, Dest);
  418.       try
  419.         Parser.Alone := False;
  420.         Parser.Filename := ToolServices.GetFormName(I);
  421.         Parser.SetKeywordType (ktDfm);
  422.         Parser.Convert;
  423.       finally
  424.         Parser.Free;
  425.         BinSource.Free;
  426.         Source.Free;
  427.       end;
  428.     end; // for
  429.  
  430.     // add the tail of the HTML file
  431.     HTML :=
  432.       '<BR><I><CENTER>HTML file generated by PasToWeb, a tool by Marco Cantù<BR>'#13#10 +
  433.       Copyright + '</CENTER></I>'#13#10 +
  434.       '</BODY> </HTML>';
  435.     Dest.WriteBuffer (Pointer(HTML)^, Length (HTML));
  436.   finally
  437.     Dest.Free;
  438.   end;
  439. end;
  440.  
  441. initialization
  442.   PascalKeywords := TStringList.Create;
  443.   DfmKeywords := TStringList.Create;
  444.  
  445.   // Pascal Keywords
  446.   PascalKeywords.Add ('absolute');
  447.   PascalKeywords.Add ('abstract');
  448.   PascalKeywords.Add ('and');
  449.   PascalKeywords.Add ('array');
  450.   PascalKeywords.Add ('as');
  451.   PascalKeywords.Add ('asm');
  452.   PascalKeywords.Add ('assembler');
  453.   PascalKeywords.Add ('at');
  454.   PascalKeywords.Add ('automated');
  455.   PascalKeywords.Add ('begin');
  456.   PascalKeywords.Add ('case');
  457.   PascalKeywords.Add ('cdecl');
  458.   PascalKeywords.Add ('class');
  459.   PascalKeywords.Add ('const');
  460.   PascalKeywords.Add ('constructor');
  461.   PascalKeywords.Add ('contains');
  462.   PascalKeywords.Add ('default');
  463.   PascalKeywords.Add ('destructor');
  464.   PascalKeywords.Add ('dispid');
  465.   PascalKeywords.Add ('dispinterface');
  466.   PascalKeywords.Add ('div');
  467.   PascalKeywords.Add ('do');
  468.   PascalKeywords.Add ('downto');
  469.   PascalKeywords.Add ('dynamic');
  470.   PascalKeywords.Add ('else');
  471.   PascalKeywords.Add ('end');
  472.   PascalKeywords.Add ('except');
  473.   PascalKeywords.Add ('exports');
  474.   PascalKeywords.Add ('external');
  475.   PascalKeywords.Add ('file');
  476.   PascalKeywords.Add ('finalization');
  477.   PascalKeywords.Add ('finally');
  478.   PascalKeywords.Add ('for');
  479.   PascalKeywords.Add ('forward');
  480.   PascalKeywords.Add ('function');
  481.   PascalKeywords.Add ('goto');
  482.   PascalKeywords.Add ('if');
  483.   PascalKeywords.Add ('implementation');
  484.   PascalKeywords.Add ('in');
  485.   PascalKeywords.Add ('index');
  486.   PascalKeywords.Add ('inherited');
  487.   PascalKeywords.Add ('initialization');
  488.   PascalKeywords.Add ('inline');
  489.   PascalKeywords.Add ('interface');
  490.   PascalKeywords.Add ('is');
  491.   PascalKeywords.Add ('label');
  492.   PascalKeywords.Add ('library');
  493.   PascalKeywords.Add ('message');
  494.   PascalKeywords.Add ('mod');
  495. //  PascalKeywords.Add ('name');
  496.   PascalKeywords.Add ('nil');
  497.   PascalKeywords.Add ('nodefault');
  498.   PascalKeywords.Add ('not');
  499.   PascalKeywords.Add ('object');
  500.   PascalKeywords.Add ('of');
  501.   PascalKeywords.Add ('on');
  502.   PascalKeywords.Add ('or');
  503.   PascalKeywords.Add ('override');
  504.   PascalKeywords.Add ('packed');
  505.   PascalKeywords.Add ('pascal');
  506.   PascalKeywords.Add ('private');
  507.   PascalKeywords.Add ('procedure');
  508.   PascalKeywords.Add ('program');
  509.   PascalKeywords.Add ('property');
  510.   PascalKeywords.Add ('protected');
  511.   PascalKeywords.Add ('public');
  512.   PascalKeywords.Add ('published');
  513.   PascalKeywords.Add ('raise');
  514.   PascalKeywords.Add ('read');
  515.   PascalKeywords.Add ('record');
  516.   PascalKeywords.Add ('register');
  517.   PascalKeywords.Add ('repeat');
  518.   PascalKeywords.Add ('requires');
  519.   PascalKeywords.Add ('resident');
  520.   PascalKeywords.Add ('set');
  521.   PascalKeywords.Add ('shl');
  522.   PascalKeywords.Add ('shr');
  523.   PascalKeywords.Add ('stdcall');
  524.   PascalKeywords.Add ('stored');
  525.   PascalKeywords.Add ('string');
  526.   PascalKeywords.Add ('then');
  527.   PascalKeywords.Add ('threadvar');
  528.   PascalKeywords.Add ('to');
  529.   PascalKeywords.Add ('try');
  530.   PascalKeywords.Add ('type');
  531.   PascalKeywords.Add ('unit');
  532.   PascalKeywords.Add ('until');
  533.   PascalKeywords.Add ('uses');
  534.   PascalKeywords.Add ('var');
  535.   PascalKeywords.Add ('virtual');
  536.   PascalKeywords.Add ('while');
  537.   PascalKeywords.Add ('with');
  538.   PascalKeywords.Add ('write');
  539.   PascalKeywords.Add ('xor');
  540.  
  541.   // DFm keywords
  542.   DfmKeywords.Add ('object');
  543.   DfmKeywords.Add ('end');
  544.  
  545. finalization
  546.   PascalKeywords.Free;
  547. end.
  548.